home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / pair.em < prev    next >
Lisp/Scheme  |  1993-07-15  |  3KB  |  126 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;; Copyright (c) University of Bath, 1993
  4. ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;; Eulisp Module
  8. ;; Author: pab
  9. ;; File: pair.em
  10. ;; Date: Tue Jun 29 21:07:48 1993
  11. ;;
  12. ;; Project:
  13. ;; Description: 
  14. ;;
  15.  
  16. (defmodule pair
  17.   (gens
  18.    defs
  19.    init
  20.    extras0
  21.    macros0
  22.    )
  23.   ()
  24.   
  25.   ;; (export <pair>)
  26.  
  27.   (defmethod initial-state ((p <pair>)) p)
  28.  
  29.   (defmethod next-state ((c <pair>) (s <pair>)) (cdr s))
  30.  
  31.   (defmethod current-element ((c <pair>) (s <pair>)) (car s))
  32.  
  33.   (defmethod (setter current-element) ((c <pair>) (s <pair>) v)
  34.     ((setter car) s v))
  35.  
  36.   (defmethod current-key ((c <pair>) (s <pair>))
  37.     (labels
  38.      ((loop (l)
  39.         (if (eq l s)
  40.         0
  41.           (+ 1 (loop (cdr l))))))
  42.      (loop c)))
  43.  
  44.   (defmethod element ((p <pair>) (i <fixint>))
  45.     (labels
  46.      ((loop (p i)
  47.         (cond
  48.          ((= i 0) (car p))
  49.          ((atom p) ())
  50.          (t (loop (cdr p) (- i 1))))))
  51.      (loop p i)))
  52.  
  53.   (defmethod (setter element) ((p <pair>) (i <fixint>) o)
  54.     (labels
  55.      ((loop (p i)
  56.         (cond
  57.          ((= i 0) ((setter car) p o))
  58.          ((atom p) ())
  59.          (t (loop (cdr p) (- i 1))))))
  60.      (loop p i)))
  61.  
  62.   (defmethod size ((c <pair>)) (length c))
  63.  
  64.   (defmethod deep-copy ((p <pair>))
  65.     ;; create a new pair and initialize with deep copies of the car and
  66.     ;; the cdr slots
  67.     (cons (deep-copy (car p)) (deep-copy (cdr p))))
  68.  
  69.   (defmethod shallow-copy ((pair <pair>))
  70.     (format t "warning: shallow-copy(pair) is (cons (car x) (cdr x))~%")
  71.     (cons (car pair) (cdr pair)))
  72.  
  73.     ;; returns a list comprising all the "top-level" pairs of sequence
  74.     ;;(labels
  75.     ;; ((loop (l)
  76.     ;;        (if (null l) () (cons (car l) (loop (cdr l))))))
  77.     ;; (loop sequence))
  78.  
  79.  
  80.   (defmethod fill ((mc <pair>) v start end)
  81.     ;; stores v in mc at the index positions between start and end
  82.     (labels
  83.      ((loop (i s)
  84.         (cond
  85.          ((null s)
  86.           ())
  87.          ((> i end)
  88.           ())
  89.          ((>= i start)
  90.           ((setter current-element) mc s v)
  91.           (loop (+ i 1) (next-state mc s)))
  92.          (t
  93.           (loop (+ i 1) (next-state mc s))))))
  94.      (if (and (<= 0 start) (<= start end) (< end (size mc)))
  95.      (loop 0 (initial-state mc))
  96.        ())))
  97.  
  98.   ;; defined here until PAB does a better version in the kernel
  99.   ;; Actually---This is OK. only improvement is that apply should
  100.   ;; be cleverer...
  101.  
  102.   (defun compose (f g) (lambda l (f (apply g l))))
  103.  
  104.   (defmethod gf-map (f (c <pair>) cs)
  105.     ;; list method for iterating over several collections
  106.     ;; simultaneously, applying the function f to the appropriate
  107.     ;; combinations of elements and constructing a list of the results.
  108.     ;; generic version in collect.em
  109.     (let ((r ()))
  110.       (apply do (compose (lambda (x) (setq r (cons x r))) f) c cs)
  111.       (reverse r)))
  112.  
  113.   (defmethod gf-member (v (c <pair>) f)
  114.     ;; returns t if the application of f to v and an element of c does
  115.     ;; see collect.em for the generic method
  116.     (labels
  117.      ((loop (l)
  118.         (cond
  119.          ((null l) ())
  120.          ((f v (car l)) l)
  121.          (t (loop (cdr l))))))
  122.      (loop c)))
  123.  
  124.   ;; end module
  125.   )
  126.